(* parsec.sml --- 
 * 
 * Filename: parsec.sml
 * Description: 
 * Author: Zhong Zhuang
 * Maintainer: 
 * Created: 05 12 2010 14:22:27 (+0800)
 * Version: 
 * Last-Updated: 06 11 2010 16:35:59 (+0800)
 *           By: Zhong Zhuang
 *     Update #: 162
 * URL: 
 * Keywords: 
 * Compatibility: 
 * 
 *)

(*             DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
 *                     Version 2, December 2004
 * 
 *  Copyright (C) 2004 Sam Hocevar
 *   14 rue de Plaisance, 75014 Paris, France
 *  Everyone is permitted to copy and distribute verbatim or modified
 *  copies of this license document, and changing it is allowed as long
 *  as the name is changed.
 * 
 *             DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
 *    TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
 * 
 *   0. You just DO WHAT THE FUCK YOU WANT TO.

 *)

(* Code: *)
structure Parsec 
(* :sig *)
(*     datatype ('a,'b) product = & of 'a * 'b *)
(*     type pos = int * int *)
(*     datatype 'a State = State of 'a list * pos *)
(*     datatype Message = Message of pos * string * string list *)
(*     datatype ('a,'b) Reply = Error of Message | Ok of 'b * 'a State * Message *)
(*     datatype ('a,'b) Consumed *)
(*       = Consumed of ('a,'b) Reply | Empty of ('a,'b) Reply *)
(*     val Msg : pos -> string -> string list -> Message *)
(*     type ('a,'b) parser = 'a State -> ('a,'b) Consumed *)
(*     val nextPos : int * int -> char -> int * int *)
(*     val satisfy : (char -> bool) -> (char,char) parser *)
(*     infix >>= *)
(*     val >>= : ('a,'b) parser * ('b -> ('a,'c) parser) -> ('a,'c) parser *)
(*     val merge : Message -> Message -> Message *)
(*     val mergeOk : 'a -> 'b State -> Message -> Message -> ('b,'a) Consumed *)
(*     val mergeError : Message -> Message -> ('a,'b) Consumed *)
(*     infix <|> *)
(*     val <|> : ('a,'b) parser * ('a,'b) parser -> 'a State -> ('a,'b) Consumed *)
(*     val return : 'a -> 'b State -> ('b,'a) Consumed *)
(*     infix >> *)
(*     val >> : ('a,'b) parser * ('a,'c) parser -> ('a,'c) parser *)
(*     val try : ('a,'b) parser -> ('a,'b) parser *)
(*     val expect : Message -> string -> Message *)
(*     infix  <?> *)
(*     val <?> : ('a,'b) parser * string -> 'a State -> ('a,'b) Consumed *)
(*     val many : ('a,'b) parser -> 'a State -> ('a,'b list) Consumed *)
(*     val many1 : ('a,'b) parser -> ('a,'b list) parser *)
(*     val skipMany : ('a,'b) parser -> ('a,unit) parser *)
(*     val skipMany1 : ('a,'b) parser -> ('a,unit) parser *)
(*     val endBy : ('a,'b) parser *)
(*                 -> ('a,'c) parser -> 'a State -> ('a,'b list) Consumed *)
(*     val endBy1 : ('a,'b) parser -> ('a,'c) parser -> ('a,'b list) parser *)
(*     val sepBy : ('a,'b) parser *)
(*                 -> ('a,'c) parser -> 'a State -> ('a,'b list) Consumed *)
(*     val sepBy1 : ('a,'b) parser -> ('a,'c) parser -> ('a,'b list) parser *)
(*     val manyTill : ('a,'b) parser -> ('a,'c) parser -> ('a,'b list) parser *)
(*     val char : char -> (char,char) parser *)
(*     val paren : (char,'a) parser -> (char,'a) parser *)
(*     val bracket : (char,'a) parser -> (char,'a) parser *)
(*     val brace : (char,'a) parser -> (char,'a) parser *)
(*     val chainl : ('a,'b) parser *)
(*                  -> ('a,'c * 'b -> 'c) parser -> 'c -> ('a,'c) parser *)
(*     val chainl1 : ('a,'b) parser *)
(*                   -> ('a,'b * 'b -> 'b) parser -> ('a,'b) parser *)
(*     val string : string -> (char,string) parser *)
(*     val digit : (char,char) parser *)
(*     val digit2int : (char,int) parser *)
(*     val integer : char State -> (char,char list) Consumed *)
(*     val alpha : (char,char) parser *)
(*     val comma : (char,char) parser *)
(*     val ident : (char,string) parser *)
(*     val showRes : ('a,'b) Consumed -> string *)
(*     val trim : string -> string *)
(*     val tokenlize : string -> char list *)
(*     val parse : string -> (char State -> ('a,'b) Consumed) -> ('a,'b) Consumed *)
(*   end *)

 = struct

datatype ('a, 'b) product = & of 'a * 'b
infix &

infix 2 >>
infix 2 >>= 
infix 1 <|> 
infix 0 <?> 



type pos = (int*int)

datatype 'c State = State of ('c list) * pos 

datatype Message = Message of pos * string * (string list)

datatype ('c,'a) Reply = Ok of 'a * ('c State) * Message
		  | Error of Message

datatype ('c,'a) Consumed = Consumed of (('c,'a) Reply)
		     | Empty of (('c,'a) Reply)

fun Msg pos str slist = Message (pos,str,slist)

type ('c,'a) parser = 'c State -> ('c,'a) Consumed 

fun nextPos (line,col) c = 
    if (c= #"\n") then (line+1,0)
    else (line,col+1)

fun satisfy(f:char->bool):((char,char) parser) =
  fn (State (cs,pos)) =>
     case cs of 
	 [] => Empty (Error (Msg pos "end of input"  []))
       | c::cs' => 
	 if (f c) then 
	     let val newPos = nextPos pos c 
		 val newState  = State (cs',newPos)
	     in 
		 Consumed (Ok (c,newState,(Msg pos "" [])))
	     end 
	 else 
	     Empty (Error (Msg pos (Char.toString c) []))
						

fun (m:('c,'a) parser) >>= (n:'a->('c,'b) parser) :('c,'b) parser =
 fn State(cs,pos) =>
    case (m (State(cs,pos))) of 
	Empty reply1 =>
	(case reply1 of 
	    Ok(c,newState,msg) => 
	    (n c newState)
	  | Error msg => Empty (Error msg))
      | Consumed reply1 =>
	Consumed 
	(
	 case reply1 of 
	     Ok(c,newState,newPos) =>
	     (case (n c newState) of 
		 Consumed reply2 => reply2 
	       | Empty reply2 => reply2)
	   | Error msg => Error msg
	)
	    


fun merge (Message(pos,str,slist1)) (Message(_,_,slist2)) = Msg pos str (slist1 @ slist2)

fun mergeOk x state msg1 msg2 =
    Empty(Ok(x,state,merge msg1 msg2))

fun mergeError msg1 msg2 =
    Empty(Error(merge msg1 msg2))


fun (m:('c,'a) parser) <|> (n:('c,'a) parser)=
    fn State(cs,pos) =>
       case (m (State(cs,pos))) of 
	   Empty (Error msg1) =>
	   (
	    case (n (State(cs,pos))) of 
		Empty (Error msg2) => mergeError msg1 msg2
	      | Empty (Ok(x,newState,msg2)) =>
		mergeOk x newState msg1 msg2
	      | consumed => consumed
	   )
	 | Empty (Ok (x,newState,msg1)) =>
	   (
	    case (n (State(cs,pos))) of 
		Empty (Error msg2) =>
		mergeOk x newState msg1 msg2
	      | Empty (Ok(_,_,msg2)) =>
		mergeOk x newState msg1 msg2
	      | consumed => consumed
	   )
	 | consumed => consumed

fun return c =
    fn State(cs,pos) =>
       Empty (Ok(c,State(cs,pos),Msg pos "" []))


fun (m:('c,'a) parser) >> (n:('c,'b) parser):('c,'b) parser=
    m >>= (fn _ => n)


fun try(p:('c,'a) parser):('c,'a) parser=
    fn State(cs,pos) =>
       case (p (State(cs,pos))) of 
	   Consumed (Error(Message(_,str,slist))) => Empty (Error (Message(pos,str,slist)))
	 | other => other

fun expect (Message(pos,state,_)) exp =
    Msg pos state [exp]

fun (p:('c,'a) parser) <?> exp =
    fn State(cs,pos) =>
       case (p (State(cs,pos))) of 
	   Empty(Error msg) => 
	   Empty(Error (expect msg exp))
	 | Empty(Ok(x,st,msg)) =>
	   Empty(Ok(x,st,expect msg exp))
	 | other => other

fun lift f = fn parser => 
		parser >>= (fn x => return (f x))

fun many parser = many1 parser <|> return []

and many1 parser = 
    parser >>= (fn x=> many parser >>=
			    (fn xs =>
				return (x::xs)))

fun skipMany parser =
    many parser >>= (fn x => return ())

fun skipMany1 parser =
    many1 parser >>= (fn x => return ())

fun endBy parser ender =
    many (try (parser>>= (fn x => ender >>= (fn _ => return x))))

fun endBy1 parser ender =
    many1 (try (parser>>= (fn x => ender >>= (fn _ => return x))))

fun sepBy parser sep =
    sepBy1 parser sep <|> return []
and sepBy1 parser sep =
    (endBy parser sep) 
	>>= 
	(fn xs => parser >>= (fn y => return (xs@[y])))

fun manyTill parser ender =
    many parser >>= 
	 (fn x =>
	     ender >>= (fn _ => return x))

fun char (c:char):(char,char) parser =
    satisfy (fn x=> x=c) <?> Char.toString c

fun paren parser =
   (char #"(") 
       >>=
       (fn _ => parser 
        >>= 
	  (fn x=> 
	      ((char #")") >>= (fn _ => return x))
	  )
       )

fun bracket parser =
    (char #"[") >>=
    (fn _ => parser >>= 
	(fn x=> char #"]" >>=
		(fn _ => return x)))

fun brace parser =
    (char #"{") >>=
    (fn _ => parser >>= 
	(fn x=> char #"}" >>=
		(fn _ => return x)))


fun chainl parser oper x =
    (oper >>=
    (fn f =>
	parser >>=
	(fn v =>
	    chainl parser oper (f (x,v)))))
	<|> (return x)

fun chainl1 parser oper =
    parser >>= 
    (fn v =>
	chainl parser oper v)


fun string str:(char,string) parser =
    let val cs = String.explode str 
    in 
	(
	 List.foldr (fn (c,p) =>
			char c >>= (fn _ => p))
		    (return ()) cs
	) >>= (fn _ => return str)
    end 


val digit = satisfy Char.isDigit
val digit2int = digit >>= (fn x=> return 
				  (Char.ord x -Char.ord #"0")
			  )

val integer = many digit
val alpha  = satisfy Char.isAlpha
val comma = char #","
val ident = alpha >>= (fn x => (many (alpha <|> digit) >>= (fn y => return (String.implode (x :: y)))))

fun showRes res = 
    let fun showMsg (Message((line,col),unexpect,expect_list)) =
	    let val pos_msg = "[At Line:" ^ Int.toString line ^ ", Col:" ^ Int.toString col ^ "]"
		val un_msg = "Unexpected input '"^unexpect^"'"
		val ex_msg = if (expect_list=[]) then ""
			     else 
				 let val body=List.foldr (op ^) "" expect_list
				 in 
				     "But Expect '"^body ^"'"
				 end
	    in 
		un_msg ^ "," ^ ex_msg ^ "," ^ pos_msg ^ "\n"
	    end	    
	fun showReply rep =
	    case rep of
		Ok(_,_,msg) => "Success!\n"
	      | Error msg => showMsg msg
    in 
	case res of 
	    Consumed reply => showReply reply
	  | Empty reply => showReply reply
    end

fun trim str =
    let val cs=String.explode str
    in 
	String.implode (List.filter (fn c=>(Char.isPrint c) andalso (not (Char.isSpace c))) cs)
    end

fun tokenlize str = String.explode (trim str)

fun parse str parser=
    let val cs = State(tokenlize str,(0,0)) 
	val res = parser cs 
    in 
	(print (showRes res);res)
    end 

(* structure Test = struct *)

(* (* test case *) *)
(* datatype Op = *)
(* 	 Add | Sub | *)
(* 	 Mul | Divide *)

(* datatype Expr = *)
(* 	 E of Op * Expr * Expr *)
(*        | F of int  *)

(* fun buildOp oper = *)
(*     fn (x,y) => E (oper,x,y) *)

(* val add = (char #"+") >>= (fn _=>return (buildOp Add)) *)
(* val sub = (char #"-") >>= (fn _=>return (buildOp Sub)) *)
(* val mul = (char #"*") >>= (fn _=>return (buildOp Mul)) *)
(* val divide = (char #"/") >>= (fn _=>return (buildOp Divide)) *)

(* val addop = (add <?> "+") <|> (sub <?> "-") *)
(* val mulop = (mul <?> "*") <|> (divide <?> "/") *)

(* fun expr cs = (chainl1 term addop) cs  *)

(* and term cs = (chainl1 factor mulop) cs  *)

(* and factor cs = ((paren expr) <|>  *)
(* 			      (((digit2int >>= *)
(* 			        (fn x=> return (F x)))) <?> "int num")) cs *)


(* val res = parse "(1+(2+3*4/(5-6)))" expr *)

(* end *)

end	
(* parsec.sml ends here *)
